home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1995 January / macformat-020.iso / Shareware City / Developers / SIOD 3.0 / sql_rdb.scm < prev    next >
Encoding:
Text File  |  1994-10-01  |  2.8 KB  |  104 lines  |  [TEXT/ttxt]
  1. ;;-*-mode:lisp-*-
  2. ;; For use with the DIGITAL RDB SQL SERVICES interface to SIOD.
  3. ;; 20-JAN-94 GJC.
  4. ;;
  5. ;; Loading (into siod linked with sql_rdb.obj)
  6. ;;  $siod -g0 -isql_rdb.scm -h150000
  7. ;;
  8. ;; Procedures: (rdb-sql-init "database-name")
  9. ;;             (rdb-sql-error?) => last sql error
  10. ;;             (rdb-sql "string") => result of operation.
  11. ;;             (rdb-show-table "table-name") => column information.
  12. ;;             (rdb-show-tables) => list all tables.
  13.  
  14. (define *rdb-sql-association* nil)
  15. (define *rdb-sql-database* nil)
  16.  
  17. (define (rdb-sql-init db)
  18.   (if (null? *rdb-sql-association*)
  19.       (begin (set! *rdb-sql-association* (rdb-sql-associate))
  20.          (if db
  21.          (set! *rdb-sql-database* db))
  22.          (if *rdb-sql-database*
  23.          (rdb-sql-execute-immediate
  24.           *rdb-sql-association*
  25.           (string-append "declare schema filename "
  26.                  *rdb-sql-database*))))))
  27.  
  28. (define (rdb-sql-error?)
  29.   (rdb-sql-error-buffer *rdb-sql-association*))
  30.  
  31. (define (rdb-sql-cleanup release-associations?)
  32.   (let ((l (rdb-sql-associations)))
  33.     (while l
  34.       (let ((s (rdb-sql-association-statements (car l))))
  35.     (while s
  36.       (rdb-sql-release (car s))
  37.       (set! s (cdr s))))
  38.       (if release-associations?
  39.       (rdb-sql-release (car l)))
  40.       (set! l (cdr l)))))
  41.  
  42. (define (unwind-protected l1 l2)
  43.   (let ((x (*catch 'errobj (l1))))
  44.     (l2)
  45.     x))
  46.  
  47. (define (rdb-sql cmd)
  48.   (rdb-sql-init nil)
  49.   (let ((s nil)
  50.     (p nil)
  51.     (l nil)
  52.     (c nil)
  53.     (result nil)
  54.     (row nil)
  55.     (rowp nil)
  56.     (x nil))
  57.     (unwind-protected
  58.      (lambda ()
  59.        (set! s (rdb-sql-prepare-cached *rdb-sql-association* cmd))
  60.        (set! p (rdb-sql-statement-params s))
  61.        (set! l (rdb-sql-statement-selects s))
  62.        (if p (error "params not implemented"))
  63.        (if (null? l)
  64.        (set! result (rdb-sql-execute s))
  65.      (begin (rdb-sql-declare-cursor s 'table 'read-only)
  66.         (set! c (rdb-sql-open-cursor s))
  67.         (while (rdb-sql-fetch s)
  68.           (set! rowp l)
  69.           (set! row nil)
  70.           (while rowp
  71.             (set! row (cons (rdb-sql-get-column s
  72.                             (car (cdr (car rowp))))
  73.                     row))
  74.             (set! rowp (cdr rowp)))
  75.           (set! result (cons (nreverse row) result)))
  76.         (set! rowp l)
  77.         (set! row nil)
  78.         (while rowp
  79.           (set! row (cons (car (car rowp)) row))
  80.           (set! rowp (cdr rowp)))
  81.         (set! result (cons (nreverse row) (nreverse result)))))
  82.        result)
  83.      (lambda ()
  84.        (if c (rdb-sql-close-cursor s))
  85.        (if s (rdb-sql-release-cached s))))))
  86.  
  87. (define rdb-sql-prepare-cached rdb-sql-prepare)
  88. (define rdb-sql-release-cached rdb-sql-release)
  89.  
  90. (define (rdb-show-tables)
  91.   (rdb-sql "select rdb$relation_name,rdb$system_flag from rdb$relations"))
  92.  
  93. (define (rdb-show-table x)
  94.   (let ((s nil)
  95.     (l nil))
  96.     (unwind-protected
  97.      (lambda ()
  98.        (set! s (rdb-sql-prepare *rdb-sql-association*
  99.                 (string-append "select * from " x)))
  100.        (rdb-describe-statement s)
  101.        (set! l (rdb-sql-statement-selects s)))
  102.      (lambda ()
  103.        (and s (rdb-sql-release s))))))
  104.